home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / editors / emcs1857 / 1857sr~1.zoo / lisp / sort-table.el < prev    next >
Encoding:
Text File  |  1992-01-24  |  3.9 KB  |  142 lines
  1. ;; Functions for dealing with sort tables.
  2. ;; Copyright (C) 1987 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is distributed in the hope that it will be useful,
  7. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  8. ;; accepts responsibility to anyone for the consequences of using it
  9. ;; or for whether it serves any particular purpose or works at all,
  10. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  11. ;; License for full details.
  12.  
  13. ;; Everyone is granted permission to copy, modify and redistribute
  14. ;; GNU Emacs, but only under the conditions described in the
  15. ;; GNU Emacs General Public License.   A copy of this license is
  16. ;; supposed to have been given to you along with GNU Emacs so you
  17. ;; can know your rights and responsibilities.  It should be in a
  18. ;; file named COPYING.  Among other things, the copyright notice
  19. ;; and this notice must be preserved on all copies.
  20.  
  21.  
  22. ;; Written by Howard Gayle.  See case-table.el for details.
  23.  
  24. (require 'case-table)
  25.  
  26. (defun describe-case-distinct-table ()
  27.    "Describe the case-distinct sort table of the current buffer."
  28.    (interactive)
  29.    (describe-sort-table (case-distinct-table))
  30. )
  31.  
  32. (defun describe-case-fold-table ()
  33.    "Describe the case-fold sort table of the current buffer."
  34.    (interactive)
  35.    (describe-sort-table (case-fold-table))
  36. )
  37.  
  38. (defun describe-sort-table (st)
  39.    "Describe the given sort table in a help buffer.  The
  40. equivalence classes are listed one per line in increasing order."
  41.    (let     (
  42.            e
  43.            (i 0)                           ; Current character.
  44.      j                               ; Steps through EC.
  45.            (v (make-vector 256 nil)) ; v[i] is EC containing char i.
  46.            )
  47.       (with-output-to-temp-buffer "*Help*"
  48.      (while (<= i 255)
  49.         (setq e (get-sort-table-ec-num i st))
  50.         (aset v e (get-sort-table-ec i st))
  51.         (setq i (1+ i))
  52.      )
  53.      (setq i 0)
  54.      (setq e (aref v i))
  55.      (while e
  56.         (setq j 0)
  57.         (while (< j (length e))
  58.            (describe-character (aref e j))
  59.            (setq j (1+ j))
  60.         )
  61.         (princ "\n")
  62.         (setq i (1+ i))
  63.         (setq e (aref v i))
  64.      )
  65.      (print-help-return-message)
  66.       )
  67.    )
  68. )
  69.  
  70. (defun expand-sort-table-list (lst)
  71.    "One argument: a list of elements in increasing order.  Each
  72. element is either a single character, which represents a
  73. singleton equivalence class, or a pair (lo . hi), which is
  74. short for all single elements in the range lo .. hi, or a list
  75. of characters, all in the same equivalence class.  Returns a
  76. list suitable for make-sort-table.  Checks for errors."
  77.    (let     (
  78.            c1 ; Current character.
  79.            c2 ; Last character in dotted pair.
  80.            ce ; Current element in lst.
  81.      (cvr (make-vector 256 nil)) ; Flag set when each char covered.
  82.      (p lst) ; Steps through lst.
  83.      q1 ; Steps through sublist.
  84.            z ; Result.
  85.            )
  86.       (while p
  87.            (setq ce (car p))
  88.      (cond
  89.         ((numberp ce)
  90.            (if (aref cvr ce)
  91.                  (message "Attempt to redefine %c (%d)" ce ce)
  92.           (setq z (cons (list ce) z))
  93.           (aset cvr ce t)
  94.            ))
  95.         ((numberp (cdr ce))
  96.            (setq c1 (car ce))
  97.            (setq c2 (cdr ce))
  98.            (while (<= c1 c2)
  99.           (if (aref cvr c1)
  100.              (message "Attempt to redefine %c (%d)" c1 c1)
  101.              (setq z (cons (list c1) z))
  102.              (aset cvr c1 t)
  103.              (setq c1 (1+ c1))
  104.           )
  105.            ))
  106.         (t
  107.            (setq q1 ce)
  108.            (while q1
  109.           (setq c1 (car q1))
  110.           (if (aref cvr c1)
  111.              (message "Attempt to redefine %c (%d)" c1 c1)
  112.              (aset cvr c1 t)
  113.           )
  114.           (setq q1 (cdr q1))
  115.            )
  116.            (setq z (cons ce z))
  117.         )
  118.      )
  119.            (setq p (cdr p))
  120.       )
  121.       (setq c1 0)
  122.       (while (<= c1 255)
  123.            (if (null (aref cvr c1))
  124.         (progn
  125.            (message "Character %c (%d) uncovered" c1 c1)
  126.            (sit-for 1)
  127.         )
  128.      )
  129.            (setq c1 (1+ c1))
  130.       )
  131.       (reverse z)
  132.    )
  133. )
  134.  
  135. (defun new-sort-table (lst)
  136.    "Return a new sort table.  Argument same as for
  137. expand-sort-table-list."
  138.    (make-sort-table (expand-sort-table-list lst))
  139. )
  140.  
  141. (provide 'sort-table)
  142.